perm filename PPROC.SAI[PNT,HE]4 blob
sn#478468 filedate 1979-09-29 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00013 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 ENTRY
C00003 00003 ! expr list => expr array
C00005 00004 ! begin,cobegin,end,coend,if,for,while,do
C00010 00005 ! case
C00014 00006 ! decl,simpledecl,arraydecl,procdecl,return
C00026 00007 ! setbase,wrist,gather,readwrist,setstiff
C00031 00008 ! vt05,print,prompt,abort,sigwait
C00033 00009 ! affix,unfix
C00036 00010 ! coordproc
C00038 00011 ! assignproc
C00041 00012 ! loadproc,dumpproc
C00054 00013 ! deflt
C00057 ENDMK
C⊗;
ENTRY;
BEGIN "PPROC"
DEFINE $$PRGID=TRUE; DEFINE $PPROC=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
RCLASS EXPR$LST(RPTR(EXPR$) PTR; RPTR(EXPR$LST) NEXT);
RCLASS EXPR$ARR(RPTR(EXPR$) ARRAY PTR);
DEFINE TOKEN_INDEX = [TOKENINDEX],TOKEN_CLASS=[tokenclass],ID_CLASS=[TOKEN_INDEX];
SIMPLE INTEGER PROCEDURE UPLEVEL(INTEGER OFFSET);
BEGIN
INTEGER I;
I ← (OFFSET +1) LSH -8 ; ! this gives the level ;
I ← (I+1) LSH 8 ; ! this gives the next level ;
RETURN(I-1);
END;
! expr list => expr array ;
RPTR(EXPR$ARR) PROCEDURE ARRIFY(RPTR(EXPR$LST)PTR);
BEGIN
! takes a list of EXPR$ records and makes them into an array;
BOOLEAN NONZERO;
INTEGER I,NRECS; RPTR(EXPR$LST)PPTR;
NONZERO←FALSE;
NRECS←0; PPTR←PTR;
WHILE PPTR DO BEGIN NRECS←NRECS+1; PPTR←EXPR$LST:NEXT[PPTR]; END;
IF NRECS THEN NONZERO←TRUE ELSE NRECS←1;
BEGIN
RPTR(EXPR$)ARRAY P[1:NRECS];
RPTR(EXPR$ARR) E;
PPTR←PTR;
IF NONZERO THEN
FOR I←1 STEP 1 UNTIL NRECS DO
BEGIN
P[I]←EXPR$LST:PTR[PPTR];
PPTR←EXPR$LST:NEXT[PPTR];
END;
E←NEW_RECORD(EXPR$ARR);
MEMORY[LOCATION(EXPR$ARR:PTR[E])]↔MEMORY[LOCATION(P)];
RETURN(E);
END;
END;
RPTR(EXPR$LST) PROCEDURE LINK(RPTR(EXPR$LST) L; RPTR(EXPR$) E);
BEGIN RPTR(EXPR$LST)LL;
EXPR$LST:NEXT[L]←LL←NEW_RECORD(EXPR$LST);
EXPR$LST:PTR[LL]←E;
RETURN(LL);
END;
! begin,cobegin,end,coend,if,for,while,do;
INTERNAL RECURSIVE PROCEDURE BEGINPROC;
BEGIN
RPTR(EXPR$LST)E$HEAD,E$CUR; RPTR(BLOCKREC)B;
INTEGER TMPOFF;
! $COMPILE←$COMPILE+1;
$LEVEL←$LEVEL+1;
TMPOFF←$TMPOFF;
B←NEW_RECORD(BLOCKREC);
BLOCKREC:NEXT[B]←CURBLOCK;
CURBLOCK←B;
E$HEAD←E$CUR←NEW_RECORD(EXPR$LST);
DO BEGIN
E$CUR←LINK(E$CUR,PARSE);
GTOKEN;
IF TOKEN≠";" AND NOT EQU(TOKEN,"END")
THEN ERROR("Need semicolon to separate statements");
END UNTIL EQU(TOKEN,"END");
! kill any new variables defined in this block ;
LINK(E$CUR,$KVARPCODE(BLOCKREC:#ARGS[CURBLOCK]));
$$PCODE←$AAPPEND(EXPR$ARR:PTR[ARRIFY(EXPR$LST:NEXT[E$HEAD])]);
CURBLOCK←BLOCKREC:NEXT[CURBLOCK];
$TMPOFF←TMPOFF;
$LEVEL←$LEVEL-1;
! $COMPILE←$COMPILE-1;
END;
INTERNAL RECURSIVE PROCEDURE COBEGINPROC;
BEGIN
RPTR(EXPR$LST)E$HEAD,E$CUR;
INTEGER TMPOFF,N$TMPOFF;
! $COMPILE←$COMPILE+1;
$LEVEL←$LEVEL+1;
TMPOFF←$TMPOFF;
N$TMPOFF←UPLEVEL($TMPOFF);
E$HEAD←E$CUR←NEW_RECORD(EXPR$LST);
DO BEGIN
RPTR(BLOCKREC)B;
B←NEW_RECORD(BLOCKREC);
BLOCKREC:NEXT[B]←CURBLOCK;
CURBLOCK←B;
$TMPOFF←N$TMPOFF;
E$CUR←LINK(E$CUR,PARSE);
CURBLOCK←BLOCKREC:NEXT[CURBLOCK];
GTOKEN;
IF TOKEN≠";" AND NOT EQU(TOKEN,"COEND")
THEN ERROR("Need semicolon to separate statements");
END UNTIL EQU(TOKEN,"COEND");
$$PCODE←$COBEGPCODE(EXPR$ARR:PTR[ARRIFY(EXPR$LST:NEXT[E$HEAD])]);
$TMPOFF←TMPOFF;
$LEVEL←$LEVEL-1;
! $COMPILE←$COMPILE-1;
END;
INTERNAL PROCEDURE ENDPROC(STRING E("END"));
BEGIN
IF $COMPILE=0 THEN ERROR("Encountered "&E&" as a statement.... strange");
STOKEN←TRUE;
$$PCODE←NULL_RECORD;
END;
INTERNAL RECURSIVE PROCEDURE IFPROC;
BEGIN
RPTR(EXPR$)COND,A,B;
! $COMPILE←$COMPILE+1;
COND←$$GTANYEXP("condition part of IF statement",#SC);
WORD_READ("THEN");
A←PARSE;
GTOKEN;
B←NULL_RECORD;
IF EQU(TOKEN,"ELSE") THEN B←PARSE
ELSE IF TOKEN=";" OR EQU (TOKEN, "END") THEN STOKEN←TRUE
ELSE ERROR("Only ELSE or ; allowed after then part");
! $COMPILE←$COMPILE-1;
$$PCODE←$IFPCODE(COND,A,B)
END;
INTERNAL RECURSIVE PROCEDURE FORPROC;
BEGIN
RPTR(SYMBOL)S;
RPTR(EXPR$)LB,UB,STE,STATE;
! $COMPILE←$COMPILE+1;
GTOKEN;
IF TOKENINDEX≠#SC THEN ERROR("Need scalar for FOR statement");
$SCLST←NULL;
S←TOKENPTR;
WORD_READ("←");
LB←$$GTANYEXP("FOR statement",#SC);
WORD_READ("STEP");
STE←$$GTANYEXP("FOR statement",#SC);
WORD_READ("UNTIL");
UB←$$GTANYEXP("FOR statement",#SC);
WORD_READ("DO");
STATE←PARSE;
$$PCODE←$FORPCODE(S,LB,STE,UB,STATE);
! $COMPILE←$COMPILE-1;
END;
INTERNAL RECURSIVE PROCEDURE WHILEPROC;
BEGIN
RPTR(EXPR$)COND,S;
! $COMPILE←$COMPILE+1;
COND←$$GTANYEXP("condition part of WHILE statement",#SC);
WORD_READ("DO");
S←PARSE;
! $COMPILE←$COMPILE-1;
$$PCODE←$WHILEPCODE(COND,S);
END;
INTERNAL RECURSIVE PROCEDURE DOPROC;
BEGIN
RPTR(EXPR$)S,COND;
! $COMPILE←$COMPILE+1;
S←PARSE;
WORD_READ("UNTIL");
COND←$$GTANYEXP("UNTIL part of DO statement",#SC);
$$PCODE←$DOPCODE(S,COND);
! $COMPILE←$COMPILE-1;
END;
! case;
RECURSIVE RPTR(CASE$) PROCEDURE CASE$REC (RPTR(CASE$)CASEXP;INTEGER NUM);
BEGIN
! creates a new record linked with casexp and fills in the
num field the number num;
RPTR(CASE$)TEMP;
TEMP←NEW_RECORD(CASE$);
CASE$:NEXT[TEMP]←CASEXP;
CASE$:NUM[TEMP]←NUM;
RETURN(TEMP);
END;
RECURSIVE RPTR(CASE$)PROCEDURE CASE$EXP (RPTR(CASE$)CASEXP;RPTR(EXPR$)EXP);
BEGIN
! inserts the pointer expr in the field body of casexp;
IF EXP= NULL!RECORD THEN EXP←EXPR$1(XNOOP);
CASE$:BODY[CASEXP]←EXP;
RETURN(CASEXP);
END;
INTERNAL RECURSIVE PROCEDURE CASEPROC;
BEGIN
RPTR(EXPR$)EXINDEX,EXS; RPTR(CASE$)EXCASE;
BOOLEAN RDELSE;INTEGER MAXNUM;
! $COMPILE←$COMPILE+1;
RDELSE←FALSE;MAXNUM←-1;
EXCASE←NULL!RECORD;
EXINDEX←$$GTANYEXP(" CASE", #SC); ! get index;
WORD_READ("OF"); WORD_READ("BEGIN");
GTOKEN;STOKEN←TRUE;
IF TOKEN="[" OR EQU(TOKEN,"ELSE")
THEN BEGIN "numbered"
INTEGER NUM;
DO BEGIN
GTOKEN;
IF EQU(TOKEN,"ELSE")
THEN IF RDELSE THEN ERROR ("only one ELSE in CASE!")
ELSE BEGIN
RDELSE←TRUE;NUM←#ELSE;
END
ELSE IF TOKEN="["
THEN BEGIN
NUM←POSINT_READ;
MAXNUM← MAXNUM MAX NUM;
WORD_READ("]");
END
ELSE ERROR("[ or ELSE expected");
! construct the record with num or #else in field num;
EXCASE←CASE$REC(EXCASE,NUM);
GTOKEN; STOKEN←TRUE;
IF TOKEN≠"[" AND ¬EQU(TOKEN,"ELSE")
THEN BEGIN
EXS←PARSE;GTOKEN;
IF TOKEN≠";" AND ¬EQU(TOKEN,"END")
THEN ERROR("need ; or END");
EXCASE←CASE$EXP(EXCASE,EXS);
STOKEN←FALSE;
END;
END UNTIL EQU(TOKEN,"END");
END "numbered"
ELSE
WHILE ¬EQU(TOKEN,"END") DO
BEGIN "unnumbered"
EXS←PARSE;
GTOKEN;
IF TOKEN≠";" AND ¬EQU(TOKEN,"END")
THEN ERROR("need ; or END");
MAXNUM←MAXNUM+1;
EXCASE←CASE$EXP(CASE$REC(EXCASE,MAXNUM),EXS);
END "unnumbered";
IF MAXNUM≠-1 THEN
$$PCODE←$CASEPCODE(EXINDEX,EXCASE,RDELSE,MAXNUM);
! $COMPILE←$COMPILE-1;
END;
! decl,simpledecl,arraydecl,procdecl,return;
INTERNAL PROCEDURE PROCDECLPROC(INTEGER OBTYPE(#PR));
BEGIN "procedure declaration"
STRING ATOKEN;INTEGER NARGS,SYMACCS;
INTEGER TMPOFF;
INTEGER ARRAY ACCESS,TYPE,ARRDIM,ARGOFF[1:10];
STRING ARRAY ARGNAME[1:10];
RPTR(SYMBOL) ARRAY SYMARR[1:10];
RPTR(PROC)PSYM; RPTR(EXPR$)PBODY; RPTR(SYMBOL)SYM; RANY DATPTR;
IF CURPROC THEN ERROR("Cant have procedure inside procedure");
IF CURBLOCK THEN ERROR("Cant have procedure inside block");
! $COMPILE←$COMPILE+1; $LEVEL←1;
GTOKEN;
IF #TOKEN≠UNDECLARED_TYPE THEN
ERROR("Need undeclared identifier for procedure declaration");
ATOKEN←TOKEN;
NARGS←0; TMPOFF←$TMPOFF; $TMPOFF←UPLEVEL(TMPOFF);! starting value ;
GTOKEN;
IF TOKEN="(" THEN
DO BEGIN "procedure with parameters"
INTEGER CACCESS,CTYPE; BOOLEAN ARRDECL;
GTOKEN;
ARRDECL←FALSE;
CACCESS←#REFTYP; SYMACCS←#SIMPLE;
IF EQU(TOKEN,"VALUE") THEN CACCESS←0
ELSE IF EQU(TOKEN,"REFERENCE") THEN CACCESS←#REFTYP
ELSE STOKEN←TRUE;
GTOKEN;
FOR CTYPE←#SC STEP 1 UNTIL #EV DO
IF EQU(TOKEN,$DTYPE[CTYPE]) THEN DONE;
IF NOT(#SC≤CTYPE≤#EV) THEN ERROR("Need basic data type declaration here");
GTOKEN;
DATPTR←NULL_RECORD;
IF EQU(TOKEN,"ARRAY") THEN
BEGIN CACCESS←#REFTYP+#ARRTYP;
ARRDECL←TRUE; SYMACCS←#ARRAY;
END ELSE STOKEN←TRUE;
DO BEGIN "get list of parameters"
INTEGER I;
IF NARGS>10 THEN ERROR("Cant take more than 10 parameters");
GTOKEN;
! now check if we have used this before ;
IF NOT(#TOKEN≠UNDECLARED_TYPE OR #TOKEN≠ID_TYPE) THEN
ERROR("Need undeclared or id token here");
FOR I←1 STEP 1 UNTIL NARGS DO
IF EQU(TOKEN,ARGNAME[I]) THEN DONE;
IF EQU(TOKEN,ATOKEN) THEN I←NARGS;
IF I≠NARGS+1 THEN ERROR(TOKEN&" has already been used in this procedure");
NARGS←NARGS+1;
TYPE[NARGS]←CTYPE; ACCESS[NARGS]←CACCESS;
ARGNAME[NARGS]←TOKEN;
ARGOFF[NARGS]←($TMPOFF←$TMPOFF+1);
IF ARRDECL THEN
BEGIN "array in argument list"
RPTR(EXPR$)E;
INTEGER I; I←0;
WORD_READ("[");
DO BEGIN "no of arguments"
E←$$GTANYEXP("for field of array declaration",#SC);
WORD_READ(":");
E←$$GTANYEXP("for dimension field of array dec",#SC);
I←I+1;
GTOKEN;
IF TOKEN≠"," AND TOKEN≠"]" THEN ERROR("Need , or ] here");
END "no of arguments" UNTIL TOKEN="]";
IF I>5 THEN ERROR("Array dimension must be less than 5");
ARRAYREC:#DIM[DATPTR←NEW_RECORD(ARRAYREC)]←ARRDIM[NARGS]←I;
END "array in argument list";
SYMBOL:OFFSET[SYMARR[NARGS]←MK_SYM(ARGNAME[NARGS],
TYPE[NARGS],DATPTR,SYMACCS)] ← $TMPOFF;
GTOKEN;
END "get list of parameters" UNTIL TOKEN≠",";
IF TOKEN≠")" AND TOKEN≠";" THEN ERROR("Need ; or , or ) here");
END "procedure with parameters" UNTIL TOKEN=")"
ELSE STOKEN←TRUE;
WORD_READ(";");
PSYM←MK_PR(NARGS,ARGNAME,TYPE,ACCESS,ARRDIM);
SYM←CURPROC←MK_SYM(ATOKEN,OBTYPE,PSYM,#PROCEDURE);
SYMBOL:OFFSET[CURPROC]←$SYMOFF;
CURBLOCK←BLOCKIFY(NARGS,SYMARR);
BLOCKREC:LEVEL[CURBLOCK]←$LEVEL;
PBODY←PARSE;
PR_SAVE(PSYM,$CLNSAVE);
$$PCODE←$PRCDCLPCODE(SYM,PBODY);
ENSYM$(SYM);
$SYMOFF←$SYMOFF+1;
! $COMPILE←$COMPILE-1;
END;
! parses the declaration instructions
SCALAR <id>,<id>,...
VECTOR <id>,<id>,...
FRAME <id>,<id>,...
ROT <id>,<id>,...
EVENT <id>,<id>,...;
INTERNAL PROCEDURE SIMPLEDECL(INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL)ARRAY SPTR[1:10];
INTEGER I,J; J←0;
DO BEGIN "A"
IF J=10 THEN ERROR("Can only declare 10 variables in a declaration");
GTOKEN;
IF (CURBLOCK=NULL_RECORD AND #TOKEN≠UNDECLARED_TYPE)
OR (CURBLOCK≠NULL_RECORD AND $LEVEL=TOKENLEVEL)
THEN ERROR("undeclared identifier required")
ELSE BEGIN "check current list"
INTEGER K;
FOR K←1 STEP 1 UNTIL J DO
IF EQU(SYMBOL:PNAME[SPTR[K]],TOKEN) THEN DONE;
IF K=J+1 THEN SPTR[J←J+1]←NNWR(TOKEN,OBTYPE)
ELSE ERROR(TOKEN&" is not undeclared");
END "check current list";
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL
THEN ERROR("; or , required");
END "A" UNTIL FINAL;
IF CURBLOCK
THEN FOR I←1 STEP 1 UNTIL J DO
BEGIN INSRTSYMTREE(SPTR[I],CURBLOCK);
SYMBOL:OFFSET[SPTR[I]]←($TMPOFF←$TMPOFF+1);
$$PCODE←$SMPDCLPCODE(OBTYPE,J);
STOKEN←TRUE;
END
ELSE FOR I←1 STEP 1 UNTIL J DO ENSYM$(SPTR[I]);
$DISPLAYLIST[OBTYPE]←NULL;
END;
! to handle array declarations;
INTERNAL PROCEDURE ARRAYDECLPROC(INTEGER OBTYPE);
BEGIN "array declaration"
RPTR(EXPR$)PARRAY;
INTEGER NARRAY;
RPTR(EXPR$) ARRAY PLIST[1:10];
RPTR(SYMBOL) ARRAY SYMLST[1:10];
NARRAY←0;
DO BEGIN "get another one"
STRING ATOKEN; INTEGER ADIM; RPTR(EXPR$)ARRAY BOUNDS[1:10];
RPTR(ARRAYREC) DIMREC;
IF NARRAY≥10 THEN ERROR("Can't have more than 10 variables in a declaration");
ADIM←0; GTOKEN;
IF (CURBLOCK=NULL_RECORD AND #TOKEN≠UNDECLARED_TYPE)
OR (CURBLOCK≠NULL_RECORD AND $LEVEL=TOKENLEVEL)
THEN ERROR("Need undeclared identifier for array declaration");
ATOKEN←TOKEN; WORD_READ("[");
DO BEGIN
IF ADIM=5 THEN ERROR("Cant have more than 5 fields in array declaration");
BOUNDS[ADIM*2+1]←$$GTANYEXP("for array dimension",#SC);
WORD_READ(":"); BOUNDS[ADIM*2+2]←$$GTANYEXP("for array dimension",#SC);
GTOKEN;
IF TOKEN≠"," AND TOKEN≠"]"THEN ERROR("Need , here"); ADIM←ADIM+1;
END UNTIL TOKEN="]";
PLIST[NARRAY←NARRAY+1]←$ARRDCLPCODE(BOUNDS,OBTYPE,ADIM,
NARRAY +(IF CURBLOCK THEN $TMPOFF ELSE $SYMOFF-1));
ARRAYREC:#DIM[DIMREC←NEW_RECORD(ARRAYREC)]←ADIM;
SYMLST[NARRAY]←MK_SYM(ATOKEN,OBTYPE,DIMREC,#ARRAY);
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL THEN ERROR("Need a comma or semicolon here");
END UNTIL FINAL;
IF TOKEN=";" THEN STOKEN←TRUE;
PARRAY←NULL_RECORD;
IF CURBLOCK THEN
BEGIN INTEGER I; RPTR(SYMBOL)S;
FOR I←1 STEP 1 UNTIL NARRAY DO
BEGIN
INSRTSYMTREE(S←SYMLST[I],CURBLOCK);
SYMBOL:OFFSET[S]←($TMPOFF←$TMPOFF+1);
PARRAY←$APPEND(PARRAY,PLIST[I]);
END;
END
ELSE BEGIN
INTEGER I; RPTR(SYMBOL)TEMP;
FOR I← 1 STEP 1 UNTIL NARRAY DO
BEGIN
ENSYM$(TEMP←SYMLST[I]);
SYMBOL:OFFSET[TEMP]←$SYMOFF;$SYMOFF←$SYMOFF+1;
PARRAY←$APPEND(PARRAY,PLIST[I]);
END;
END;
$$PCODE←PARRAY;
END "array declaration";
INTERNAL PROCEDURE DECLPROC (INTEGER OBTYPE);
BEGIN
GTOKEN;
IF EQU(TOKEN,"PROCEDURE")
THEN BEGIN $COMPILE←$COMPILE+1; PROCDECLPROC(OBTYPE);
$COMPILE←$COMPILE-1; END
ELSE IF EQU(TOKEN,"ARRAY")
THEN ARRAYDECLPROC(OBTYPE)
ELSE BEGIN
STOKEN←TRUE;
SIMPLEDECL(OBTYPE);
END;
END;
INTERNAL PROCEDURE RETURNPROC;
BEGIN RPTR(EXPR$)EXP;
IF $COMPILE=0 THEN ERROR("RETURN can only be inside a block");
EXP←NULL_RECORD; GTOKEN;
IF TOKEN="(" THEN
BEGIN EXP←$$GTEXPR; GTOKEN;
IF TOKEN≠")" THEN ERROR("Need right paren here");
END
ELSE STOKEN←TRUE;
$$PCODE←$RTNPCODE(EXP);
END;
! setbase,wrist,gather,readwrist,setstiff;
INTERNAL PROCEDURE SETBASEPROC;
$$PCODE←$SETBASEPCODE;
INTERNAL PROCEDURE WRISTPROC;
BEGIN RPTR(SYMBOL) S;
WORD_READ("("); GTOKEN;
IF TOKENPTR=NULL_RECORD OR
SYMBOL:TYPE[TOKENPTR]≠#SC OR
SYMBOL:ACCESS[TOKENPTR]≠#ARRAY
OR ARRAYREC:#DIM[SYMBOL:OBJECT[TOKENPTR]]≠1
THEN ERROR("Need one dimensioned scalar array in WRIST");
S←TOKENPTR; WORD_READ(")");
$$PCODE←$WRISTPCODE(S);
END;
IFC #GATHER THENC
PRELOAD_WITH "FX","FY","FZ","MX","MY","MZ","T1","T2","T3","T4","T5","T6","TBL";
STRING ARRAY GATHCODES[0:12];
INTERNAL PROCEDURE GATHERPROC;
BEGIN INTEGER STATUS,I; INTEGER S1;
WORD_READ("("); STATUS←0;
DO BEGIN
GTOKEN;
FOR I←0 STEP 1 UNTIL 12 DO IF EQU(TOKEN,GATHCODES[I]) THEN DONE;
IF I>12 THEN ERROR("Unrecognized code found: ",TOKEN);
STATUS←STATUS LOR ('1 LSH I);
GTOKEN;
END UNTIL TOKEN≠",";
IF TOKEN≠")" THEN ERROR("Need right paren here");
$$PCODE←$GATHERPCODE(STATUS);
END;
ENDC
IFC #WRIST THENC
INTERNAL PROCEDURE READWRISTPROC;
BEGIN STRING COMMAND,FNAME; INTEGER VAL;
VAL←0;FNAME←NULL;
WORD_READ("(");
GTOKEN;
COMMAND←TOKEN;
IF EQU("CALIB",COMMAND) OR EQU("RENAMEFILE",COMMAND) THEN
BEGIN
GTOKEN;
IF TOKEN≠"," THEN ERROR("Need comma after CALIB or RENAMEFILE");
IF EQU(COMMAND,"CALIB") THEN
BEGIN
GTOKEN;
VAL←INTSCAN(TOKEN,$BRCHR);
IF VAL<1 OR VAL>6
THEN ERROR("Calib code must be between 1 and 6");
END
ELSE FNAME←NAMEFILE;
END
ELSE IF EQU("SAVERAWDATA",COMMAND) THEN
BEGIN
STRING S; S←NULL;
GTOKEN;
IF TOKEN≠"," THEN ERROR("Need comma after SAVERAWDATA");
GTOKEN;
IF TOKEN≠"""" THEN ERROR("need double quote here");
GTOKEN;
WHILE TOKEN≠"""" DO BEGIN S←S&TOKEN&" "; GTOKEN; END;
FNAME←S;
END;
WORD_READ(")");
GTOKEN(FALSE);
IF NOT FINAL THEN ERROR("This is an incomplete instruction")
ELSE IF EQU(COMMAND,"READ") THEN
$$PCODE←$RFORCEPCODE
ELSE IF VAL←RWRIST(COMMAND,VAL,FNAME) THEN
ERROR("ERROR in reading wrist",$WRMSG[VAL]);
END;
ENDC
INTERNAL PROCEDURE SETSTIFFPROC;
BEGIN
RPTR(EXPR$) ARRAY E[1:8];
INTEGER NARGS;
WORD_READ("("); NARGS←0;
DO BEGIN
E[NARGS←NARGS+1]←$$GTANYEXP("argument in SETSTIFF",#SC);
GTOKEN;
END UNTIL TOKEN≠"," OR NARGS=6;
IF TOKEN≠"," THEN ERROR("Need comma here")
ELSE E[7]←$$GTANYEXP("argument in SETSTIFF",#FR);
GTOKEN;
IF TOKEN≠")" THEN ERROR("Need right paren after 7th argument");
E[8]←$SETSTFPCODE;
$$PCODE←$AAPPEND(E);
END;
INTERNAL PROCEDURE DDTPROC;
$$PCODE←$DDTPCODE;
! vt05,print,prompt,abort,sigwait;
INTERNAL PROCEDURE VT05PROC(INTEGER STATE);
$$PCODE←$VT05PCODE(STATE);
RPTR(EXPR$)PROCEDURE PRINTCODE;
BEGIN
RPTR(EXPR$LST)E$HEAD,E$CUR;
E$HEAD←E$CUR←NEW_RECORD(EXPR$LST);
WORD_READ("(");
DO BEGIN
GTOKEN;
IF TOKEN=dquote
THEN BEGIN "string found"
READTILL(dquote);
E$CUR←LINK(E$CUR,$PRPCODE(TOKEN))
END
ELSE BEGIN "expression found"
STOKEN←TRUE;
E$CUR←LINK(E$CUR,$PRVPCODE($$GTEXPR));
END;
GTOKEN;
END UNTIL TOKEN≠",";
IF TOKEN≠")" THEN ERROR("Need ) for end of PRINT list");
RETURN($AAPPEND(EXPR$ARR:PTR[ARRIFY(EXPR$LST:NEXT[E$HEAD])]));
END;
INTERNAL PROCEDURE PRINTPROC;
$$PCODE←PRINTCODE;
INTERNAL PROCEDURE ABORTPROC;
$$PCODE←$APPEND(PRINTCODE,$ABORTPCODE);
INTERNAL PROCEDURE PROMPTPROC;
$$PCODE←$APPEND(PRINTCODE,$PROMPTPCODE);
INTERNAL PROCEDURE SIGWAITPROC(BOOLEAN SIGNAL);
BEGIN
RPTR(EXPR$)TEMP;rptr(symbol)sym;
TEMP←IDREF(SYM);
$$PCODE←$SIGWAITPCODE(TEMP,SIGNAL);
END;
! affix,unfix;
INTERNAL PROCEDURE UNFIXPROC;
BEGIN
RPTR(EXPR$)EX1,EX2; RPTR(SYMBOL)FRM1,FRM2;
EX1←$$GTIDREF(#FR,FRM1,"first frame of unfix");
IF SYMBOL:TYPE[FRM1]=#TR
THEN IF SYMBOL:ACCESS[FRM1]=#SIMPLE THEN FRM1←CNVRTR(FRM1,SYMBOL:PNAME[FRM1])
ELSE ERROR("UNFIX: need a simple trans or a frame here");
WORD_READ("FROM"); ! change this to handle just UNFIX FRAME1;
EX2←$$GTIDREF(#FR,FRM2,"second frame of UNFIX");
IF SYMBOL:TYPE[FRM2]=#TR
THEN IF SYMBOL:ACCESS[FRM2]=#SIMPLE THEN FRM2←CNVRTR(FRM2,SYMBOL:PNAME[FRM2])
ELSE ERROR("UNFIX: need a simple trans or a frame here");
$$PCODE←$UFXPCODE(EX1,EX2);
END;
! parses the instruction
AFFIX <frame_id> TO <frame_id> {AT TRANS(<rot>,<vector>)};
INTERNAL PROCEDURE AFFIXPROC;
BEGIN
INTEGER AFFTYPE;RPTR(EXPR$)TEMP;
RPTR(EXPR$)EX1,EX2; RPTR(SYMBOL)FRM1,FRM2;
EX1←$$GTIDREF(#FR,FRM1,"first frame of affix");
IF SYMBOL:TYPE[FRM1]=#TR
THEN IF SYMBOL:ACCESS[FRM1]=#SIMPLE THEN FRM1←CNVRTR(FRM1,SYMBOL:PNAME[FRM1])
ELSE ERROR("AFFIX: need a simple trans or a frame here");
WORD_READ("TO");
EX2←$$GTIDREF(#FR,FRM2,"second frame of affix");
IF SYMBOL:TYPE[FRM2]=#TR
THEN IF SYMBOL:ACCESS[FRM2]=#SIMPLE THEN FRM2←CNVRTR(FRM2,SYMBOL:PNAME[FRM2])
ELSE ERROR("AFFIX: NEED A SIMPLE TRANS OR A FRAME HERE");
GTOKEN(FALSE);
TEMP←NULL_RECORD;
IF EQU(TOKEN,"AT")
THEN BEGIN "AT"
TEMP←$$GTANYEXP("offset part of AFFIX statement",#FR);
GTOKEN(FALSE);
END "AT";
IF FINAL
THEN AFFTYPE←#RGDLK
ELSE BEGIN "D"
IF TOKEN="+" OR EQU(TOKEN,"NONRIGIDLY") THEN AFFTYPE← #NRGLK
ELSE IF TOKEN="*" OR EQU(TOKEN,"RIGIDLY") THEN AFFTYPE← #RGDLK
ELSE ERROR("invalid affix type");
! SEMICOL_READ; ! commented out to clean up;
END "D";
$$PCODE←$AFXPCODE(EX1,EX2,AFFTYPE,TEMP);
END ;
! coordproc;
INTERNAL PROCEDURE COORDPROC (INTEGER ELEMENT,TYPE);
BEGIN
RPTR(EXPR$) EX1,EX2; RPTR(SYMBOL) S;INTEGER TYPEF;
S←NULL_RECORD; ! element=0,1,2,3 depending on instr;
WORD_READ("(");
EX1←IDREF(S); ! read the argument&look for predeclared;
IF PRDECL(S) THEN
ERROR("You cannot change the value of"&SYMBOL:PNAME[S] );
! check for correct type of argument;
CASE (TYPEF←EXPR$:TYPE[EX1]) OF
BEGIN
[#SC][#RT] ERROR("unexpected type");
[#VT] IF ELEMENT=0 THEN ERROR("unexpected type");
ELSE
END;
WORD_READ(")");
WORD_READ("←");
! reads the expression according to the type;
CASE TYPE OF
BEGIN
[#SC] EX2←$$GTANYEXP("X-Y-Z coord",#SC);
[#VT] EX2←$$GTANYEXP("POS",#VT);
[#RT] EX2←$$GTANYEXP("ORIENT",#RT);
ELSE ERROR("COORDPROC: unexpected type")
END;
$DISPLAYLIST[TYPEF]←NULL;
$$PCODE←$COORDPCODE(EX1,EX2,ELEMENT,TYPE);
END;
! assignproc;
! assigns to first the expression following, assuming that FIRST has not
been declared. This works only for simple variables;
PROCEDURE ASGEX3(STRING FIRST);
BEGIN RPTR(EXPR$)LHS,RHS; INTEGER TY; RPTR(SYMBOL)S;
RHS←$$GTEXPR;
S←INSERT(FIRST,TY←EXPR$:TYPE[RHS]);
LHS←EXPR$ID(S);
$$PCODE←$ASGPCODE(LHS,RHS);
END;
INTERNAL PROCEDURE ASGEX2(RPTR(SYMBOL)S;RPTR(EXPR$)LHS);
BEGIN RPTR(EXPR$)RHS; INTEGER TY;
RHS←$$GTEXPR;
IF (TY←SYMBOL:TYPE[S])=#FR AND EXPR$:TYPE[RHS]=#TR THEN
EXPR$:TYPE[RHS]←#FR
ELSE IF TY=#TR AND EXPR$:TYPE[RHS]=#FR
THEN CNVRTR(S,SYMBOL:PNAME[S])
ELSE IF EXPR$:TYPE[RHS]≠TY THEN ERROR("INCOMAPTABILE TYPE ASSIGNMENT");
$$PCODE←$ASGPCODE(LHS,RHS);
END;
PROCEDURE ASGMNT(RPTR(SYMBOL)S;RPTR(EXPR$)EE);
IF PRDECL(S) THEN
ERROR("You cannot change the value of "&SYMBOL:PNAME[S])
ELSE ASGEX2(S,EE);
INTERNAL PROCEDURE ASSIGNPROC;
BEGIN STRING FIRST; RPTR(SYMBOL)SS; RPTR(EXPR$)EE;
FIRST←TOKEN; EE←NULL_RECORD;
IF (SS←TOKENPTR)≠NULL_RECORD THEN
IF SYMBOL:ACCESS[TOKENPTR]=#PROCEDURE
THEN BEGIN $$PCODE←PREF(TOKENPTR);
RETURN; END
ELSE BEGIN STOKEN←TRUE; EE←IDREF(SS); END;
GTOKEN;
! EE=NULL_RECORD implies is an undeclared id;
IF TOKEN="←"
THEN IF EE THEN ASGMNT(SS,EE)
ELSE IF $LEVEL=0 THEN ASGEX3(FIRST)
ELSE ERROR("Cant make implicit declaration inside a block")
ELSE ERROR("unrecognized instruction");
END;
! loadproc,dumpproc;
DEFINE #BUFSIZE=256;
INTEGER ARRAY BUFVAL[1:#BUFSIZE]; ! buffer ;
INTEGER BUFPTR; ! pointer to BUFVAL;
INTEGER BUFCH; ! channel used by LOAD/DUMP;
BOOLEAN BUF_USED;
! output the buffer BUFVAL (BUFPTR words) and start a new buffer;
PROCEDURE NEWBUF;
BEGIN
IF BUFPTR=0 THEN RETURN;
BUF_USED←TRUE;
WORDOUT(BUFCH,BUFPTR); ! number of words in bufval;
ARRYOUT(BUFCH,BUFVAL[1],BUFPTR);
BUFPTR←0;ARRCLR(BUFVAL);
END;
! read from the file into BUFVAL (MAXPTR words);
INTEGER PROCEDURE READBUF;
BEGIN
integer maxptr;
BUFPTR←0;ARRCLR(BUFVAL);
ARRYIN(BUFCH,BUFVAL[1], MAXPTR←WORDIN(BUFCH));
RETURN(MAXPTR);
END;
! pushes integer J into the buffer (as ipush);
SIMPLE PROCEDURE INTPUSH(INTEGER J);
BUFVAL[BUFPTR←BUFPTR+1]←J;
! pushes real value R into buffer ;
SIMPLE PROCEDURE FLPUSH(REAL R);
MEMORY[LOCATION(BUFVAL[BUFPTR←BUFPTR+1]),REAL]←R;
! gets integer from the buffer;
INTEGER PROCEDURE INTGET;
RETURN(BUFVAL[BUFPTR←BUFPTR+1]);
! gets real number from the buffer;
REAL PROCEDURE FLGET;
RETURN(MEMORY[LOCATION(BUFVAL[BUFPTR←BUFPTR+1]),REAL]);
! the string is converted into numbers and placed in BUFVAL;
PROCEDURE NUMBFY(STRING NAME);
BEGIN
WHILE NAME DO BEGIN
INTPUSH(CVASC(NAME));
NAME←NAME[6 TO ∞];
END;
BUFVAL[BUFPTR]←BUFVAL[BUFPTR] LOR 1; comment last bit=1 for last word;
END;
! the numbers taken from BUFVAL are converted into string;
STRING PROCEDURE STRINGFY;
BEGIN
STRING ST;
ST←NULL;
DO ST←ST&CVASTR(INTGET)
UNTIL BUFVAL[BUFPTR] LAND 1; comment check when last bit=1;
RETURN(ST);
END;
BOOLEAN PROCEDURE UNDECLARED(STRING NAME);
RETURN(IF CHECKTOT(NAME)=NULL_RECORD THEN TRUE ELSE FALSE);
PROCEDURE INSRTLOAD(RPTR(SYMBOL)SYMPTR;REFERENCE RPTR(SYMBOL)SYMDAD;
INTEGER HOW(#INDLK));
BEGIN
INTEGER TYPE;
ENSYM$(SYMPTR,TYPE←SYMBOL:TYPE[SYMPTR]);
IF TYPE=#FR
THEN BEGIN
FRAME:HOWLINKED[SYMBOL:OBJECT[SYMPTR]]←HOW;
IF SYMDAD=NULL_RECORD OR SYMBOL:TYPE[SYMDAD]≠#FR
THEN BEGIN
! name is not a frame. The affixment is done to STATION;
PRINT(SYMBOL:PNAME[SYMDAD]&" is not a frame."
&SYMBOL:PNAME[SYMPTR]&" affixed to STATION"&crlf);
SYMDAD←WORLD;
END;
LINKFR(SYMBOL:OBJECT[SYMPTR],SYMBOL:OBJECT[SYMDAD]);
END;
END;
! simpload, arrload, var$load, loadcode;
RPTR(EXPR$)PROCEDURE SIMPLOAD(INTEGER TYPE;INTEGER HOWMANY(1));
BEGIN
! read from BUFVAL and construct the expr$;
PRELOAD_WITH 1,3,3,6,6,0;
OWN INTEGER ARRAY MULTIPLIER[#SC:#EV];
INTEGER I,N;
N←MULTIPLIER[TYPE]*HOWMANY;
FOR I←1 STEP 1 UNTIL N DO FPUSH(FLGET);
RETURN(βEXPR$);
END;
RPTR(EXPR$)PROCEDURE ARRLOAD(RPTR(SYMBOL)SYMPTR;INTEGER TYPE);
BEGIN
RPTR(ARRAYREC)OBJECT;INTEGER I,DIM,EL;
RPTR(EXPR$)TEMP;RPTR(SYMBOL)SYMDAD;
INTEGER ARRAY LB,UB,MUL[1:5];
! no frame array allowed;
OBJECT←SYMBOL:OBJECT[SYMPTR];
ARRAYREC:#DIM[OBJECT]←DIM←INTGET;
EL←INTGET;
FOR I←1 STEP 1 UNTIL DIM DO BEGIN
LB[I]←INTGET;
UB[I]←INTGET;
MUL[I]←INTGET;
END;
TEMP←SIMPLOAD(TYPE,EL);
IF UNDECLARED(SYMBOL:PNAME[SYMPTR])
THEN BEGIN
INSRTLOAD(SYMPTR,SYMDAD);
SYMBOL:OFFSET[SYMPTR]←$SYMOFF;$SYMOFF←$SYMOFF+1;
SYMPTR←NWAREC(SYMPTR,EL,LB,UB,MUL);
RETURN(L$ARRPCODE(SYMPTR,TYPE,TEMP));
END
ELSE begin
PRINT("ARRAY "&SYMBOL:PNAME[SYMPTR]&" not loaded because existent"&crlf);
RETURN(NULL_RECORD);END;
END;
RPTR(EXPR$) PROCEDURE VAR$LOAD;
BEGIN "VARLOAD"
INTEGER TYPE,ACCESS,TYPACC,HOWLINKED;STRING NAME;
RPTR(SYMBOL)SYMPTR,SYMDAD;
RPTR(EXPR$)TEMP;TEMP←NULL_RECORD;
! reads the information related to one variable;
TYPACC←INTGET;TYPE←TYPACC MOD 10;ACCESS←TYPACC DIV 10;
NAME←STRINGFY;
CASE ACCESS OF
BEGIN
[#SIMPLE] BEGIN
TEMP←SIMPLOAD(TYPE);
IF TYPE=#FR
THEN BEGIN
HOWLINKED← INTGET;
SYMDAD←CHECKTOT(STRINGFY);
END;
IF UNDECLARED(NAME)
THEN BEGIN
INSRTLOAD(SYMPTR←NNWR(NAME,TYPE,ACCESS),
SYMDAD,HOWLINKED);
RETURN(L$SIMPCODE(SYMPTR,TYPE,TEMP));
END;
END;
[#ARRAY] BEGIN
SYMPTR←MK_SYM(NAME,TYPE,NEW_RECORD(ARRAYREC),#ARRAY);
RETURN(ARRLOAD(SYMPTR,TYPE));
END;
[#ARRAY_ELEMENT] ERROR("LOAD can't handle array_elements"&crlf);
ELSE ERROR("unexistent access"&crlf)
END;
PRINT(NAME&" is not loaded because existent"&crlf);
RETURN(NULL_RECORD);
END "VARLOAD";
INTERNAL PROCEDURE LOADPROC(STRING FILE);
BEGIN
INTEGER MAXPTR,EOF,BR,I;RPTR(EXPR$LST) $HEAD,$CUR;RPTR(EXPR$)TEMP;
IF FILE_ABSENT(FILE) THEN
ERROR("LOAD error: nonexistent file "&FILE);
BUFCH←OREADFILE(FILE,EOF,'10); ! binary mode;
DO BEGIN "READ LOOP"
MAXPTR←READBUF;
$HEAD←$CUR←NEW_RECORD(EXPR$LST);
WHILE BUFPTR<MAXPTR DO
IF (TEMP←VAR$LOAD)≠NULL_RECORD THEN $CUR←LINK($CUR,TEMP);
IF EXPR$LST:NEXT[$HEAD]≠NULL_RECORD
THEN $execute(
$AAPPEND(EXPR$ARR:PTR[ARRIFY(EXPR$LST:NEXT[$HEAD])]));
END "READ LOOP"
UNTIL MAXPTR=0;
RELEASE(BUFCH);
FOR I←#MIN STEP 1 UNTIL #BASIC_TYPES DO $DISPLAYLIST[I]←NULL;
END;
! simpdump, dumpcode;
PROCEDURE SIMPDUMP(RPTR(SYMBOL)SYMPTR;INTEGER TYPE);
BEGIN
INTEGER I; RANY OBJECT;
! dump type, name and value(s);
IF $ELFABORTED THEN OBJECT←SYMBOL:OBJECT[SYMPTR] ELSE OBJECT←$EVAL11(SYMPTR);
CASE TYPE OF
BEGIN
[#SC] FLPUSH(SCALAR:VALUE[OBJECT]);
[#VT] BEGIN
FLPUSH(VECTOR:XC[OBJECT]);
FLPUSH(VECTOR:YC[OBJECT]);
FLPUSH(VECTOR:ZC[OBJECT]);
END;
[#RT] FOR I←4 STEP 1 UNTIL 6 DO
FLPUSH(ROT:XF[OBJECT][I]);
[#TR] FOR I←1 STEP 1 UNTIL 6 DO
FLPUSH(TRANS:XF[OBJECT][I]);
[#FR] BEGIN
FOR I←1 STEP 1 UNTIL 6 DO
FLPUSH(FRAME:XF[OBJECT][I]);
INTPUSH(FRAME:HOWLINKED[OBJECT]);
NUMBFY(FRAME:PNAME[FRAME:DAD[OBJECT]]);
END;
[#EV]
END;
END;
RECURSIVE PROCEDURE FRAMEDUMP(RPTR(FRAME) ND);
BEGIN
INTEGER I;RPTR(FRAME) SN;STRING S;
! dump the frame tree (SIMPLEDUMP for all the frames in the tree);
IF NOT(ND=F_WRLD OR EQU(S←FRAME:PNAME[ND],"BPARK")
OR EQU(S,"YPARK") OR EQU(S,"BARM")OR EQU(S,"YARM")
OR EQU(S,"BGRASP"))
THEN BEGIN
IF BUFPTR≥#BUFSIZE-20 THEN NEWBUF;
INTPUSH(SYMBOL:ACCESS[FRAME:SYM[ND]]*10+#FR);
NUMBFY(SYMBOL:PNAME[FRAME:SYM[ND]]);
SIMPDUMP(FRAME:SYM[ND],#FR);
END;
SN←FRAME:SON[ND];
WHILE SN≠NULL_RECORD DO
BEGIN
FRAMEDUMP(SN);
SN←FRAME:EBRO[SN];
END;
END;
PROCEDURE ARRDUMP(RPTR(SYMBOL)SYMPTR;INTEGER TYPE);
BEGIN
RPTR(ARRAYREC)OBJECT;
INTEGER I,DIM,EL;
! check how many words required:
3*#dim (array lb,ub,mul) + #el*n (values) + 5 (header) + 3*#el(for frames)
where n=1,3,6;
OBJECT←SYMBOL:OBJECT[SYMPTR]; ! appropriate pointer;
INTPUSH(DIM←ARRAYREC:#DIM[OBJECT]); ! #dim;
INTPUSH(EL←ARRAYREC:#EL[OBJECT]); ! #el;
FOR I←1 STEP 1 UNTIL DIM DO BEGIN
INTPUSH(ARRAYREC:LB[OBJECT][I]);
INTPUSH(ARRAYREC:UB[OBJECT][I]);
INTPUSH(ARRAYREC:MUL[OBJECT][I]);
END;
FOR I←1 STEP 1 UNTIL EL DO
SIMPDUMP(ARRAYREC:PTR[OBJECT][I],TYPE);
END;
INTERNAL PROCEDURE DUMPPROC(STRING FILE);
BEGIN "dump"
! dump simple variables;
RPTR(SYMBOL) SYMPTR;INTEGER I,TYPE,PROT,FLAG;
IF NOT FILE_ABSENT(FILE)
THEN BEGIN
PRINT("file "&file&" exists. Type Y to replace"); CLRBUF;
IF INCHRW≠"Y" THEN ERROR("DUMP not executed") ELSE PRINT(CRLF);
END;
BUFCH←OWRITEFILE(FILE,'10);
FRAMEDUMP(F_WRLD);
FOR TYPE←#SC,#VT,#RT,#TR,#EV DO BEGIN
NEWBUF;
FOR I←OFFSET[RES_OFFSET,TYPE]+1 STEP 1 UNTIL $ENTRY[TYPE] DO
IF (SYMPTR←$YMTAB[TYPE,I])≠NULL_RECORD
THEN BEGIN
IF BUFPTR≥#BUFSIZE-20 THEN NEWBUF;
INTPUSH(SYMBOL:ACCESS[SYMPTR]*10+TYPE);
NUMBFY(SYMBOL:PNAME[SYMPTR]);
CASE SYMBOL:ACCESS[SYMPTR] OF
BEGIN
[#SIMPLE] SIMPDUMP(SYMPTR,TYPE);
[#ARRAY] ARRDUMP(SYMPTR,TYPE);
[#PROCEDURE]print("DUMP of procedures not yet implemented"&crlf);
else ERROR("unexistent access"&crlf)
END;
END;
end;
IF ¬BUF_USED
THEN BEGIN RENAME(BUFCH,"",PROT,FLAG);
PRINT("DUMP file not created"&crlf);END
ELSE CLOSE(BUFCH);
RELEASE(BUFCH);
END "dump";
! deflt;
INTERNAL PROCEDURE DEFLT(STRING HOW);
BEGIN
IF EQU(OLDCMD,"OPEN") OR EQU(OLDCMD,"CLOSE")
THEN OPENING(OLDCMD,OLDOBJ,HOW)
ELSE IF EQU(OLDCMD,"MOVEX")OR EQU(OLDCMD,"MOVEY")OR EQU(OLDCMD,"MOVEZ")
THEN IF HOW="BY"
THEN ALONGPROC(OLDCMD[5 FOR 1],OLDOBJ)
ELSE ERROR("BY required")
ELSE IF EQU(OLDCMD,"DRIVE")
THEN JTMOVE("BJT",HOW,CVD(OLDOBJ))
ELSE IF EQU(OLDCMD,"MOVE")
THEN IF EQU(HOW,"BY") THEN PBYPROC ELSE PTOPROC;
END;
END "PPROC";